home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue40 / Alfresco / AACDate.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-11-01  |  4.4 KB  |  126 lines
  1. {*********************************************************}
  2. {* AACDate                                               *}
  3. {* Copyright (c) Julian M Bucknall 1998                  *}
  4. {* All rights reserved.                                  *}
  5. {*********************************************************}
  6. {* Various date calculation routines                     *}
  7. {*********************************************************}
  8.  
  9. {Note: this unit is released as freeware. In other words, you are free
  10.        to use this unit in your own applications, however I retain all
  11.        copyright to the code. JMB}
  12.  
  13. unit AACDate;
  14.  
  15. interface
  16.  
  17. function GetDateForDayOfMonth(aWhichOne : integer;
  18.                               aDay      : integer;
  19.                               aMonth    : integer;
  20.                               aYear     : integer) : TDateTime;
  21.   {-returns the date of the aWhichOne'th aDay of aMonth/aYear; if
  22.     there is no such date, returns 0.0}
  23.  
  24. procedure GetISODate(aDate : TDateTime;
  25.                  var aYear : integer;
  26.                  var aWeek : integer;
  27.                  var aDay  : integer);
  28.   {-return the ISO date (year, week number and day of week) for a
  29.     given date. Under the ISO system, week 1 of a year is the week
  30.     containing the first Thursday of the year; a week starts with
  31.     a Monday and ends with a Sunday.}
  32.  
  33.  
  34. implementation
  35.  
  36. uses
  37.   SysUtils;
  38.  
  39. function GetDateForDayOfMonth(aWhichOne : integer;
  40.                               aDay      : integer;
  41.                               aMonth    : integer;
  42.                               aYear     : integer) : TDateTime;
  43. var
  44.   Month1st : TDateTime;
  45.   Day1st   : integer;
  46. begin
  47.   {validate}
  48.   if (aDay < 1) or (aDay > 7) then
  49.     raise Exception.Create('The day should be between 1 (Sunday) and 7 (Saturday)');
  50.   if (aMonth < 1) or (aMonth > 12) then
  51.     raise Exception.Create('The month should be between 1 and 12');
  52.   if (aWhichOne < 1) or (aWhichOne > 5) then
  53.     raise Exception.Create('The WhichOne value should be between 1 (first) and 5 (fifth)');
  54.   {calculate}
  55.   Month1st := EncodeDate(aYear, aMonth, 1);
  56.   Day1st := DayOfWeek(Month1st);
  57.   if (Day1st <= aDay) then
  58.     Result := aDay - Day1st + ((aWhichOne-1) * 7) + Month1st
  59.   else
  60.     Result := aDay - Day1st + (aWhichOne * 7) + Month1st;
  61.   if (Result - Month1st + 1) > MonthDays[IsLeapYear(aYear), aMonth] then
  62.     Result := 0.0;
  63. end;
  64.  
  65. function CalcFirstWeek(aYear : integer) : TDateTime;
  66. {-returns the date of the Monday of week 1 of the given year}
  67. const
  68.   DOWThu = 5;
  69. var
  70.   Month1stJan : TDateTime;
  71.   Day1stJan   : integer;
  72. begin
  73.   Month1stJan := EncodeDate(aYear, 1, 1);
  74.   Day1stJan := DayOfWeek(Month1stJan);
  75.   if (Day1stJan <= DOWThu) then
  76.     Result := DOWThu - Day1stJan + Month1stJan - 3
  77.   else
  78.     Result := DOWThu - Day1stJan + Month1stJan + 4;
  79. end;
  80.  
  81. procedure GetISODate(aDate : TDateTime;
  82.                  var aYear : integer;
  83.                  var aWeek : integer;
  84.                  var aDay  : integer);
  85. var
  86.   WeekOneStart: TDateTime;
  87.   Year     : word;
  88.   Month    : word;
  89.   Day      : word;
  90. begin
  91.   {calculate the date of the Monday for the first week for the date's
  92.    year}
  93.   DecodeDate(aDate, Year, Month, Day);
  94.   WeekOneStart := CalcFirstWeek(Year);
  95.   {if the given date is greater than/equal to the 1st week start date
  96.    calculate the week number and day number}
  97.   if (aDate >= WeekOneStart) then begin
  98.     aYear := Year;
  99.     aWeek := (Trunc(aDate - WeekOneStart) div 7) + 1;
  100.     aDay := (Trunc(aDate - WeekOneStart) mod 7) + 1;
  101.     {check to see if the given date could appear in the first week of
  102.      the following year, if so so do the same calculation again, but
  103.      for the next year}
  104.     if ((aDate - WeekOneStart) > 364) then begin
  105.       WeekOneStart := CalcFirstWeek(Year+1);
  106.       if (aDate >= WeekOneStart) then begin
  107.         aYear := Year+1;
  108.         aWeek := (Trunc(aDate - WeekOneStart) div 7) + 1;
  109.         aDay := (Trunc(aDate - WeekOneStart) mod 7) + 1;
  110.       end;
  111.     end;
  112.   end
  113.   {if the given date is less than the 1st week start date, it'll be in
  114.    the last week of the previous year, so do the same calculation
  115.    again, but for the prior year}
  116.   else begin
  117.     dec(Year);
  118.     WeekOneStart := CalcFirstWeek(Year);
  119.     aYear := Year;
  120.     aWeek := (Trunc(aDate - WeekOneStart) div 7) + 1;
  121.     aDay := (Trunc(aDate - WeekOneStart) mod 7) + 1;
  122.   end;
  123. end;
  124.  
  125. end.
  126.